(FILECREATED " 1-FEB-74  2:46:42" RECORD.TEM

     changes to:  RECORDERROR,MAKECREATE,MAKEINSTANCE,RECORDVARS,
SPECIFIED,RECORDECL1,DECLSUBFIELD,ADD.SAME.LEVEL,ADD.SUBFIELD,ADDFIELD
,RECORDECL,ACCESSDEF,MAKECREATE1

     previous date: "30-JAN-74 19:40:25")


(LISPXPRINT (QUOTE RECORDVARS) T)
(RPAQQ RECORDVARS ((FNS RECORD1 ADDGLOBVAR RECORDECL RECORDECL1
DECLTHISREC SETUPARRAY 'CAR LISTRECORDEFS MAKERPLAC COMPOSE 'CDR
DWIMIFYREC RECORDERROR DECLSUBFIELD ADDFIELD) (FNS CLISPRECORD 
RECRESPELL MYSUBST RECLISPLOOKUP MYSUBST1 ACCESSDEF GETLOCALDEC)
(FNS RECCOMPOSE0 RECORDWORD RECLOOK) (VARS CLISPRECORDTYPES 
CLISPRECORDWORDS CRLIST (RECORDSPLIST (LIST NIL)) (CHANGEDRECLST
NIL) (USERRECORDS NIL) (RECORDSUBSTFLG (QUOTE @@)) (ACCESSNOTRANFLG
T)) (PROP CLISPWORD * CLISPRECORDWORDS) (PROP PRETTYTYPE RECORDS)
(ADDVARS (PRETTYTYPELST (CHANGEDRECLST RECORDS "records")) (
PRETTYMACROS (RECORDS X (PD * (MAPCAR (QUOTE X) (FUNCTION (LAMBDA
(Z) (OR (LISTP Z) (LISTP (GETP Z (QUOTE CLISPRECORD))) (ERROR Z
"not a record")))))))) (SYSPROPS CLISPRECORD CLISPRECORDFIELD))
(FNS CLISPNOTRAN MAKECREATE MAKEINSTANCE SPECIFIED RECCOMPOSE 
MAKECREATELST SETPACK 'CONS) (BLOCKS (RECORDBLOCK (ENTRIES RECORD1
CLISPRECORD RECORDECL RECCOMPOSE0) RECORD1 ADDGLOBVAR RECORDECL
RECORDECL1 DECLTHISREC SETUPARRAY 'CAR LISTRECORDEFS MAKERPLAC COMPOSE
'CDR DWIMIFYREC RECORDERROR DECLSUBFIELD CLISPRECORD RECRESPELL
MYSUBST RECLISPLOOKUP MYSUBST1 ACCESSDEF GETLOCALDEC RECCOMPOSE0
RECORDWORD RECLOOK CLISPNOTRAN MAKECREATE MAKEINSTANCE SPECIFIED
RECCOMPOSE MAKECREATELST SETPACK 'CONS (GLOBALVARS CLISPRECORDWORDS
CLISPRECORDTYPES RECORDSPLIST RECORDSUBSTFLG RECORDSTATS USERRECORDS
CRLIST) (SPECVARS EXPR FAULTFN VARS CLISPCHANGE REDECLARELST) (
LOCALFREEVARS RECORD.HASHED CREATESTATEMENT BINDINGS BLIP 
FIELDS.IN.CREATE USINGTYPE RECEXPR DECLST YITEM XITEM RECORDECLARATION
SUBRECSTODO))) (FNS MAKECREATE1)))
(DEFINEQ

(RECORD1
(LAMBDA (DECL) (* This function does the work of the top level record
declaration functions; all of the translating information is stored
via RECORDECL; this just keeps track of the PROPS and of those record
expressions which have been changed (notice the MAPHASH thru the
CLISPARRAY at the end)) (PROG ((FAULTFN (QUOTE TYPE-IN)) VARS (EXPR
DECL) HASHED REDECLARELST TEM NAME) (* EXPR, VARS, and FAULTFN are
rebound because dwimifying of the defaults is done with DWIMIFY1B,
which assumes them) RETRY (COND ((AND (NULL TEM) (NULL (CDDR DECL))
(EQ (CAR DECL) (CAR (SETQ TEM (GETP (CADR DECL) (QUOTE CLISPRECORD))))))
(* Feature: saying (RECORD FOO) if FOO has a CLISPRECORD PROP, just
redeclares FOO - Useful if you edit the property - Check for TEM
keeps this from looping infinitely) (SETQ DECL (CONS (CAR TEM) (CDR
TEM))) (GO RETRY))) (OR (SETQ HASHED (RECORDECL DECL T)) (RECORDERROR
(QUOTE BADEC) DECL)) (COND ((SETQ NAME (CADR HASHED)) (COND ((SETQ
TEM (GETP NAME (QUOTE CLISPRECORD))) (SETQ REDECLARELST (LIST (SETQ
TEM (CAR (RECORDECL TEM (QUOTE DON'TFIX)))) NAME)) (* REDCLARELST
is used for the MAPHASH - Here we get the RECORD name - Note that
REDECLARELST has the format ((list of fields) recordname)) (MAPC
TEM (FUNCTION (LAMBDA (X) (/REMPROP X (QUOTE CLISPRECORDFIELD))
(/DREMOVE X RECORDSPLIST)))) (AND (NULL DFNFLG) (LISPXPRINT (CONS
(QUOTE record) (CONS NAME (QUOTE (redeclared)))) T)))) (ADDGLOBVAR
NAME (QUOTE USERRECORDS)) (/PUT NAME (QUOTE CLISPRECORD) DECL)))
(AND FILEPKGFLG (ADDGLOBVAR (OR NAME DECL) (QUOTE CHANGEDRECLST)))
(MAPC (CAR HASHED) (FUNCTION (LAMBDA (FIELD) (AND (LITATOM FIELD)
(PROG (TEM TEM2) (COND ((OR (SETQ TEM (GETP FIELD (QUOTE 
CLISPRECORDFIELD))) (FMEMB FIELD SYSPROPS)) (COND (REDECLARELST
(OR (FMEMB FIELD (CAR REDECLARELST)) (FRPLACA REDECLARELST (CONS
FIELD (CAR REDECLARELST))))) (T (SETQ REDECLARELST (LIST (LIST FIELD)))))
(AND TEM (NULL DFNFLG) (LISPXPRINT (CONS (QUOTE field) (CONS FIELD
(NCONC1 (COND ((SETQ TEM2 (CADR (RECORDECL TEM (QUOTE DON'TFIX))))
(LIST (QUOTE of) TEM2))) (QUOTE redeclared)))) T)))) (ADDSPELL FIELD
RECORDSPLIST) (/PUT FIELD (QUOTE CLISPRECORDFIELD) DECL)))))) (AND
REDECLARELST CLISPARRAY (MAPHASH CLISPARRAY (FUNCTION (LAMBDA (X
Y) (AND X (COND ((FMEMB (CAR Y) (QUOTE (fetch FETCH replace REPLACE)))
(SOME (CDR Y) (FUNCTION (LAMBDA (ZZ) (FMEMB ZZ (CAR REDECLARELST))))))
((FMEMB (CAR Y) CLISPRECORDWORDS) (EQ (CADR Y) (CADR REDECLARELST))))
(/PUTHASH Y NIL CLISPARRAY)))))) (RETURN NAME))))

(ADDGLOBVAR
(LAMBDA (VAL AT) (OR (COND ((LISTP VAL) (MEMBER VAL (CAR AT))) (T
(FMEMB VAL (CAR AT)))) (/RPLACA AT (CONS VAL (CAR AT))))))

(RECORDECL
(LAMBDA (DECL FLG) (* Fixes up the record declaration DECL if it
hasn't already been fixed, and get the "MEANING" of the declaration
(stored in the CLISPTRAN) ; if the RECORD is in an intermediate
state of translation, this "MEANING" field is (NIL)) (* Each RECORD
has the following properties: - NAME: the name of a RECORD; subrecords
have this only to match the appropriate field - - FIELDS: a list
of all fields contained in this RECORD and any subrecords; used
for lookup, and spelling correction - - TYPECHECK: a fn/form of
how to check type (this is optional, of course; not all RECORD types
can be type-checked) - - CREATE: a fn/form of how to create an 
instance of this RECORD - - FIELDINFO: a list of the field information
for each field - - SUBFIELDS: the subfields of the entire (!) RECORD
- - DEFAULT: the universal default (in default←form)) (* For each
field (in fieldinfo) there is the following information: - FIELDNAME:
the name of this field - - DEFAULT: the default value in a create
- - ACCESSDEF: fn/form of what x:field means - - SETDEF: fn/form
of what x:field←value means - - SUBFIELDS: the sub-record declarations
for subfields) (COND ((NLISTP DECL) NIL) ((AND (EQ (CAR DECL) 
CLISPTRANFLG) (FMEMB (CADDR DECL) CLISPRECORDTYPES)) (* Record begins
with "CLISP%% ") (RECORDECL1 (CADR DECL) (CDDR DECL) FLG)) ((NOT
(FMEMB (CAR DECL) CLISPRECORDTYPES)) NIL) (T (RECORDECL1 (OR (GETHASH
DECL CLISPARRAY) (PROG (TEM) (SETQ TEM (LIST NIL)) (CLISPTRAN DECL
TEM) (RETURN TEM))) (COND ((EQ (CAR DECL) CLISPTRANFLG) (* Incase
the CLISPTRAN above put a "CLISP " in) (CDDR DECL)) (T DECL)) FLG)))))

(RECORDECL1
(LAMBDA (HASHED RECORDECLARATION FLG ACCESS) (* FLG is either NIL
meaning that the fields only are needed, T meaning that ALL the
info is needed, or a "superior" record declaration meaning that
this is an internal (sub-record) declaration) (PROG (TEM1 TEM2 TAIL)
(COND ((EQ FLG (QUOTE DON'TFIX)) (RETURN HASHED))) (COND ((NULL
(CDR HASHED)) (SETQ TEM1 (DECLTHISREC RECORDECLARATION FLG)) (RPLNODE
HASHED (MAPCAR (CADR TEM1) (QUOTE CAR)) TEM1))) (COND ((EQ (CAAR
(CDDDDR HASHED)) (QUOTE NOT←DONE)) (AND (CDAR (CDDDDR HASHED)) (PROG
(LOCALVARS (TAIL (CDAR (CDDDDR HASHED))) DWIMDFLG SUBRECSTODO) (SETQ
LOCALVARS (CONS (QUOTE DEFAULT) (CAR HASHED))) LP (COND ((NULL TAIL)
(MAPC (CDAR (CDDDDR HASHED)) (FUNCTION (LAMBDA (X) (DECLSUBFIELD
X HASHED)))) (RETURN)) ((AND (LISTP (CAR TAIL)) (OR (FMEMB (CAAR
TAIL) CLISPRECORDTYPES) (AND (EQ (CAAR TAIL) CLISPTRANFLG) (FMEMB
(CADAR TAIL) CLISPRECORDTYPES)))) (* Got a sub-record declaration
- DECLSUBFIELD checks if it is a subrecord, and inserts the 
appropriate info) (SETQ TAIL (CDR TAIL))) ((AND (FMEMB (CAR TAIL)
LOCALVARS) (EQ (CADR TAIL) (QUOTE ←))) (PROG ((VARS (APPEND LOCALVARS
VARS))) (DWIMIFY1B TAIL RECORDECLARATION T T T FAULTFN)) (ADDFIELD
(CAR TAIL) (CADDR TAIL) HASHED TAIL) (SETQ TAIL (CDDDR TAIL))) (T
(SELECTQ (CAR (LISTP (CAR TAIL))) ((SETQ SAVESETQ)) ((SETQQ SAVESETQQ)
(/RPLNODE (CAR TAIL) (QUOTE SETQ) (LIST (CADAR TAIL) (KWOTE (CADDR
(CAR TAIL)))))) (COND (DWIMDFLG (RECORDERROR (QUOTE NOFIELD) TAIL
RECORDECLARATION)) (T (DWIMIFYREC TAIL LOCALVARS RECORDECLARATION)
(SETQ DWIMDFLG T) (GO LP)))) (COND ((FMEMB (CADAR TAIL) LOCALVARS)
(ADDFIELD (CADAR TAIL) (CADDR (CAR TAIL)) HASHED TAIL) (SETQ TAIL
(PROG1 (CDR TAIL) (/RPLNODE TAIL (CADAR TAIL) (CONS (QUOTE ←) (CONS
(CADDR (CAR TAIL)) (CDR TAIL))))))) ((FIXSPELL (CADAR TAIL) 70 
LOCALVARS NIL (CDAR TAIL) NIL T) (GO LP)) (T (RECORDERROR (QUOTE
FIELDS) TAIL RECORDECLARATION))))) (GO LP))) (MAP (CADDR HASHED)
(FUNCTION (LAMBDA (Y) (AND (FASSOC (CAAR Y) (CDR Y)) (RECORDERROR
(QUOTE TWICE) (CAAR Y) RECORDECLARATION))))) (RPLACA (CDDDDR HASHED)
NIL))) (RETURN HASHED))))

(DECLTHISREC
(LAMBDA (RECORDECLARATION FLG) (PROG (NAME TYPECHECK FIELDINFO TAIL
TEM1 TEM2 ACCESS CREATEINFO) (SETQ ACCESS (QUOTE BODY)) (SETQ NAME
(CADR RECORDECLARATION)) (SETQ TAIL (CDDDR RECORDECLARATION)) (SETQ
FIELDINFO (SELECTQ (CAR RECORDECLARATION) (RECORD (LISTRECORDEFS
(SETQ CREATEINFO (COND ((LISTP (CADR RECORDECLARATION)) (SETQ NAME)
(SETQ TAIL (CDDR RECORDECLARATION)) (CADR RECORDECLARATION)) (T
(OR (LISTP (CADDR RECORDECLARATION)) (RECORDERROR (QUOTE BADEC)
RECORDECLARATION)) (CADDR RECORDECLARATION)))) ACCESS)) (TYPERECORD
(COND ((LISTP (CADR RECORDECLARATION)) (* (TYPERECORD (LIST))) (
RECORDERROR (QUOTE BADEC) RECORDECLARATION))) (SETQ TYPECHECK (LIST
(QUOTE EQ) (QUOTE (CAR BODY)) (KWOTE NAME))) (LISTRECORDEFS (CONS
NIL (CDR (SETQ CREATEINFO (CONS NAME (CADDR RECORDECLARATION)))))
ACCESS)) ((PROPRECORD ATOMRECORD OPTIONS PROPS) (SETQ TEM1 (COND
((LISTP (CADR RECORDECLARATION)) (SETQ NAME NIL) (SETQ TAIL (CDDR
RECORDECLARATION)) (CADR RECORDECLARATION)) ((NLISTP (CADDR 
RECORDECLARATION)) (SETQ TAIL) (CDDR RECORDECLARATION)) (T (CADDR
RECORDECLARATION)))) (OR (AND (LISTP TEM1) (EVERY TEM1 (FUNCTION
(LAMBDA (X TAIL) (COND ((LITATOM X) (AND (NOT (STRPOSL (QUOTE (:
←)) X)) (OR (LISTP TAIL) (NULL TAIL)))) (T (EVERY X (QUOTE LITATOM))))))))
(RECORDERROR (QUOTE BADEC) RECORDECLARATION)) (* The decision of
when to "CAR SKIP" (i.e. to insert an extra field at the beginning
of the record in order to have something to FRPLAC into is: Yes,
if this is a top-level declaration, or if it isn't the subfield
of a RECORD or TYPERECORD)) (COND ((EQ (CAR RECORDECLARATION) (QUOTE
ATOMRECORD)) (SETQ TYPECHECK (QUOTE (LITATOM BODY)))) ((NOT (SETQ
TEM2 (AND (OR (EQ (CAR FLG) (QUOTE RECORD)) (EQ (CAR FLG) (QUOTE
TYPERECORD))) (QUOTE (CDR BODY))))) (SETQ CREATEINFO (CONS (CADR
(SETQ TYPECHECK (LIST (QUOTE EQ) (KWOTE (OR NAME (QUOTE PROPRECORD)))
(QUOTE (CAR BODY))))) TEM1))) (T (SETQ CREATEINFO (CONS NIL TEM1))))
(MAPCAR TEM1 (FUNCTION (LAMBDA (FIELD) (COND ((EQ (CAR 
RECORDECLARATION) (QUOTE ATOMRECORD)) (COND ((LITATOM FIELD) (LIST
FIELD (LIST (QUOTE GETP) ACCESS (KWOTE FIELD)) (LIST (QUOTE PUT)
ACCESS (KWOTE FIELD) (QUOTE ITEM)))) (T (LIST (CAR FIELD) (LIST
(QUOTE CADR) (LIST (QUOTE GETLIS) (QUOTE BODY) (KWOTE FIELD))) (LIST
(QUOTE PUT) (QUOTE BODY) (KWOTE (CAR FIELD))))))) (T (LIST (OR (CAR
(LISTP FIELD)) FIELD) (COND ((LISTP FIELD) (LIST (QUOTE CADR) (LIST
(QUOTE GETLIS) (COND (TEM2 ACCESS) (T ('CDR ACCESS))) (KWOTE FIELD))))
(T (LIST (QUOTE GET) (COND (TEM2 ACCESS) (T ('CDR ACCESS))) (KWOTE
FIELD)))) (LIST (COND (TEM2 (QUOTE PUTL)) (T (QUOTE PUTLD))) ACCESS
(KWOTE (OR (CAR (LISTP FIELD)) FIELD)) (QUOTE ITEM))))))))) (
ARRAYRECORD (SETQ TEM1 (COND ((LISTP (CADR RECORDECLARATION)) (SETQ
NAME NIL) (SETQ TAIL (CDDR RECORDECLARATION)) (CADR RECORDECLARATION))
((NLISTP (CADDR RECORDECLARATION)) (SETQ TAIL) (CDDR RECORDECLARATION))
(T (CADDR RECORDECLARATION)))) (OR (AND (LISTP TEM1) (EVERY TEM1
(FUNCTION (LAMBDA (X TAIL) (COND ((SMALLP X)) ((LISTP X) (AND (LITATOM
(CAR X)) (LITATOM (CDR X)))) ((LITATOM X) (AND (NOT (STRPOSL (QUOTE
(: ←)) X)) (OR (LISTP TAIL) (NULL TAIL))))))))) (RECORDERROR (QUOTE
BADEC) RECORDECLARATION)) (SETQ CREATEINFO) (SETQ TYPECHECK (QUOTE
(ARRAYP BODY))) (PROG (VAL (CNT 0)) LP (COND ((NULL TEM1) (SETQ
CREATEINFO (CONS CNT CREATEINFO)) (RETURN VAL)) ((NUMBERP (CAR TEM1))
(SETQ CNT (IPLUS CNT (CAR TEM1)))) (T (SETQ CNT (ADD1 CNT)) (COND
((CAR TEM1) (SETQ CREATEINFO (NCONC1 CREATEINFO (CONS (CAR TEM1)
CNT))) (COND ((OR (NLISTP (CAR TEM1)) (CAAR TEM1)) (SETQ VAL (CONS
(LIST (COND ((LISTP (CAR TEM1)) (CAAR TEM1)) (T (CAR TEM1))) (LIST
(QUOTE ELT) (QUOTE BODY) CNT) (LIST (QUOTE SETA) (QUOTE BODY) CNT
(QUOTE ITEM))) VAL)))) (COND ((AND (LISTP (CAR TEM1)) (CDR TEM1))
(SETQ VAL (LIST (LIST (CDR TEM1) (LIST (QUOTE ELTD) (QUOTE BODY)
CNT) (LIST (QUOTE SETD) (QUOTE BODY) CNT)))))))))) (SETQ TEM1 (CDR
TEM1)) (GO LP))) ((HASHRECORD HASHLINK) (SETQ TEM1 (COND ((LISTP
(CADR RECORDECLARATION)) (* (HASHLINK (FOO))) (COND ((FMEMB (CAADR
RECORDECLARATION) CLISPRECORDTYPES) (* (HASHLINK (RECORD --))) (SETQ
NAME) (SETQ TAIL (CDR RECORDECLARATION)) (LIST (GENSYM))) (T (SETQ
NAME (AND (NLISTP FLG) (CAADR RECORDECLARATION))) (SETQ TAIL (CDDR
RECORDECLARATION)) (CADR RECORDECLARATION)))) ((NULL (CDR 
RECORDECLARATION)) (* (HASHLINK)) (RECORDERROR (QUOTE BADEC) 
RECORDECLARATION)) ((OR (NULL (CDDR RECORDECLARATION)) (FMEMB (CAR
(LISTP (CADDR RECORDECLARATION))) CLISPRECORDTYPES)) (* (HASHLINK
FOO) OR (HASHLINK FOO (RECORD ---))) (COND ((LISTP FLG) (SETQ NAME)))
(SETQ TAIL (CDDR RECORDECLARATION)) (LIST (CADR RECORDECLARATION)))
((NLISTP (CADDR RECORDECLARATION)) (* (HASHLINK FIE FUM) means (
HASHLINK FIE (FUM))) (LIST (CADDR RECORDECLARATION))) (T (CADDR
RECORDECLARATION)))) (SETQ TEM2 (COND ((NUMBERP (CADR TEM1)) (
SETUPARRAY (OR (CADDR TEM1) (CAR TEM1)) (CADR TEM1))) (T (SETUPARRAY
(CADR TEM1) (CADDR TEM1))))) (LIST (LIST (CAR TEM1) (CONS (QUOTE
GETHASH) (CONS ACCESS TEM2)) (CONS (QUOTE PUTHASH) (CONS ACCESS
(CONS (QUOTE ITEM) TEM2)))))) ((ACCESSFNS ACCESSFN) (OR (AND (EVERY
(SETQ TEM1 (COND ((LITATOM (CAR (SETQ TEM1 (COND ((LISTP (CADR 
RECORDECLARATION)) (SETQ TAIL (CDDR RECORDECLARATION)) (SETQ NAME)
(CADR RECORDECLARATION)) (T (CADDR RECORDECLARATION)))))) (LIST
TEM1)) (T TEM1))) (FUNCTION (LAMBDA (X) (AND (LISTP X) (LITATOM
(CAR X)))))) (PROGN (FOR X IN TEM1 DO (DWIMIFYREC (CDR X) (QUOTE
(BODY ITEM)) X)) (EVERY TEM1 (FUNCTION (LAMBDA (X) (NULL (CDDDR
X))))))) (RECORDERROR (QUOTE BADEC) RECORDECLARATION)) TEM1) (
ARRAYRECORD (PROG ((CNT 0)))) ((ACCESSFN ACCESSFNS) (RECORDERROR
(QUOTE NOTIMP) RECORDECLARATION)) (RECORDERROR (QUOTE BADEC) 
RECORDECLARATION))) (RETURN (LIST NAME FIELDINFO TYPECHECK (CONS
(QUOTE NOT←DONE) TAIL) (LIST (CAR RECORDECLARATION) CREATEINFO))))))

(SETUPARRAY
(LAMBDA (NAME SIZE) (AND SIZE (NOT (NUMBERP SIZE)) (RECORDERROR
(QUOTE BADEC) SIZE RECORDECLARATION)) (OR (NULL NAME) (ARRAYP (CAR
NAME)) (AND (NOT (LITATOM NAME)) (RECORDERROR (QUOTE BADEC) NAME
RECORDECLARATION)) (AND (LISTP (CAR NAME)) (ARRAYP (CAAR NAME)))
(SAVESET NAME (CONS (HARRAY (OR SIZE 100))))) (AND NAME (LIST NAME))))

('CAR
(LAMBDA (X) (AND X (PROG (TEM) (COND ((OR (NLISTP X) (NULL (SETQ
TEM (CADR (FASSOC (CAR X) CRLIST))))) (LIST (QUOTE CAR) X)) (T (LIST
TEM (CADR X))))))))

(LISTRECORDEFS
(LAMBDA (FORMAT DEF) (COND ((NULL FORMAT) NIL) ((LISTP FORMAT) (NCONC
(AND (CAR FORMAT) (LISTRECORDEFS (CAR FORMAT) ('CAR DEF))) (AND
(CDR FORMAT) (LISTRECORDEFS (CDR FORMAT) ('CDR DEF))))) ((LITATOM
FORMAT) (LIST (LIST FORMAT DEF (MAKERPLAC DEF)))) (T (RECORDERROR
(QUOTE INVFIELD) FORMAT RECORDECLARATION)))))

(MAKERPLAC
(LAMBDA (FORM) (PROG (TEM TEM2) (OR (SETQ TEM (CDDDR (FASSOC (COND
((LISTP FORM) (CAR FORM)) (T FORM)) CRLIST))) (RETURN (AND (SELECTQ
(CAR FORM) (GETHASH (CONS (QUOTE PUTHASH) (CONS (CADR FORM) (CONS
(QUOTE ITEM) (CDDR FORM))))) (GET (COMPOSE (CONS (QUOTE PUTL) (CONS
(QUOTE BODY) (CDDR FORM))) (CADR FORM) T)) NIL) (HELP "IS THIS RIGHT?"))))
(SETQ TEM2 (SELECTQ (CAR TEM) (CAR (QUOTE RPLACA)) (CDR (QUOTE RPLACD))
(HELP))) (COND ((AND (NLISTP FORM) (NULL (CADR TEM))) TEM2) (T (SETQ
FORM (COND ((NLISTP FORM) (QUOTE BODY)) (T (CADR FORM)))) (LIST
TEM2 (COND ((CADR TEM) (LIST (CADR TEM) FORM)) (T FORM)) (QUOTE
ITEM)))))))

(COMPOSE
(LAMBDA (EXPR1 EXPR2 RPLFLG) (* Make EXPR1 of EXPR2) (PROG NIL (COND
((LISTP EXPR2)) ((EQ EXPR2 (QUOTE BODY)) (RETURN EXPR1)) (T (SETQ
EXPR2 (LIST EXPR2 (QUOTE BODY))))) (COND ((NLISTP EXPR1) (CONS EXPR1
(CONS EXPR2 (COND (RPLFLG (QUOTE (ITEM))) (T NIL))))) ((AND RPLFLG
(EQ (CAR EXPR1) (QUOTE PUTL))) (PROG ((TEM2 (FASSOC (CAR EXPR2)
CRLIST))) (RETURN (LIST (SELECTQ (CADDDR TEM2) (CAR (QUOTE PUTLA))
(CDR (QUOTE PUTLD)) (GO NOCARCDR)) (COND ((CAR (CDDDDR TEM2)) (LIST
(CAR (CDDDDR TEM2)) (CADR EXPR2))) (T (CADR EXPR2))) (CADDR EXPR1)
(QUOTE ITEM))) NOCARCDR (HELP "error in record package" 
"function COMPOSE"))) (T (SUBST EXPR2 (QUOTE BODY) EXPR1))))))

('CDR
(LAMBDA (X) (AND X (PROG (TEM) (COND ((OR (NLISTP X) (NULL (SETQ
TEM (CADDR (FASSOC (CAR X) CRLIST))))) (LIST (QUOTE CDR) X)) (T
(LIST TEM (CADR X))))))))

(DWIMIFYREC
(LAMBDA (TAIL NEWVARS PARENT) (PROG ((VARS (APPEND NEWVARS VARS)))
(AND RECORDSUBSTFLG (SETQ VARS (CONS (QUOTE @) VARS))) (DWIMIFY1B
TAIL PARENT TAIL T NIL FAULTFN))))

(RECORDERROR
(LAMBDA (MESSAGE AT IN CDRFLG) (PROG (TEM) (FIXPRINTIN FAULTFN)
(SETQ MESSAGE (SELECTQ MESSAGE (NOTFIRSTFIELD 
"field from other than first sub-record specified") (SUBFIELDNOTIMP
"CREATE on records with subfields not implemented") (NOTIMP 
"this feature not implemented in the record package yet:
") (OF "no OF") (NOCREATE "no CREATE specified") (INVFIELD 
"invalid record field") (TWICE "Record field specified twice") (BOTH
"both field and subfield specified in record declaration") (BADEC
"bad record declaration") ((NOFIELD NOFIELDS) 
"missing a 'field←' in record expression ") (MISMATCH 
"Record subfield with no corresponding name in primary record")
(FIELDS "Unrecognized field name") (COND ((AND (LISTP MESSAGE) (EQ
(CDR MESSAGE) (QUOTE BOTH))) (CONCAT "two subfields of " (CAR MESSAGE)
" in different sub-records both have been specified")) (T MESSAGE))))
(COND ((NLISTP MESSAGE) (LISPXPRIN1 MESSAGE T)) (T (MAPRINT MESSAGE
T NIL NIL NIL NIL T))) (COND ((IGREATERP (POSITION T) 40) (LISPXTERPRI
T))) (COND ((OR (EQ AT IN) (NULL IN)) (LISPXPRIN1 " in  " T) (
LISPXPRINT (RETDWIM2 AT) T) (ERROR!))) (LISPXPRIN1 " at   " T) (COND
((AND AT (NLISTP AT)) (LISPXPRIN1 AT T) (LISPXPRIN1 "    " T)) ((SETQ
TEM (OR (NULL AT) (TAILP AT IN) (MEMB AT IN))) (MAPRINT (RETDWIM2
(COND (CDRFLG (NLEFT IN 1 TEM)) (T TEM)) (CDDR AT)) T "... " ")
" NIL NIL T)) (T (LISPXPRINT (RETDWIM2 AT) T))) (LISPXPRIN1 "in    "
T) (LISPXPRINT (RETDWIM2 IN) T) (COND ((LISTP AT) (CDR AT)) ((NULL
AT) (PROG1 IN (SETQ IN)))) IN (* Tell it that this is an external
call) (ERROR!))))

(DECLSUBFIELD
(LAMBDA (SUBREC HASHED) (* DECLARATIONS: FAST) (PROG (SUBHASH SUBNAME
TEM2) (COND ((NLISTP SUBREC) (RETURN)) ((EQ (CAR SUBREC) CLISPTRANFLG)
(/RPLNODE2 SUBREC (CDDR SUBREC))) ((NOT (FMEMB (CAR (LISTP SUBREC))
CLISPRECORDTYPES)) (RETURN)) ((NOT (SETQ SUBHASH (PROGN (AND 
CLISPARRAY (GETHASH SUBREC NIL CLISPARRAY) (/PUTHASH SUBREC NIL
CLISPARRAY)) (RECORDECL SUBREC RECORDECLARATION)))) (RECORDERROR
(QUOTE BADEC) SUBREC RECORDECLARATION))) (COND ((SETQ SUBNAME (CDR
(FASSOC SUBREC SUBRECSTODO))) (AND (CADR SUBHASH) (RECORDERROR (QUOTE
BADEC) RECORDECLARATION)) (FRPLACA (CDR SUBHASH) SUBNAME)) (T (SETQ
SUBNAME (CADR SUBHASH)))) (COND ((SETQ TEM2 (FASSOC SUBNAME (CADDR
HASHED))) (PROG ((HASHED (CDDDDR HASHED))) (* %% INSERT THE SUBFIELD)
(FRPLACD (CDR HASHED) (CONS (NCONC1 (CADDR HASHED) SUBHASH) (CDDDR
HASHED)))) (FRPLACA (CDDR HASHED) (NCONC (MAPCAR (CADDR SUBHASH)
(FUNCTION (LAMBDA (X) (LIST (CAR X) (COMPOSE (CADR X) (CADR TEM2))
(COMPOSE (CADDR X) (CADR TEM2)))))) (CADDR HASHED))) (* Insert the
field FETCH and REPLACE information) (FRPLACD (SETQ TEM2 (OR (FMEMB
(CAR TEM2) (CAR HASHED)) (FLAST (CAR HASHED)))) (APPEND (CAR SUBHASH)
(CDR TEM2))) (* Insert the field names)) ((OR (NULL SUBNAME) (EQ
(CADR HASHED) SUBNAME)) (PROG ((HASHED (CDDDDR HASHED))) (* %% INSERT
SUB DECLARATION) (FRPLACD (CDR HASHED) (CONS (CADDR HASHED) (NCONC1
(CDDDR HASHED) SUBHASH)))) (NCONC (CADDR HASHED) (APPEND (CADDR
SUBHASH))) (* %% INSERT FETCH AND REPLACE INFO) (NCONC (CAR HASHED)
(APPEND (CAR SUBHASH))) (* %% INSERT FIELD NAMES)) (T (RECORDERROR
(QUOTE MISMATCH) SUBREC RECORDECLARATION))) (RETURN T))))

(ADDFIELD
(LAMBDA (VAR VAL HASHED TAIL) (COND ((FMEMB (CAR (LISTP VAL)) 
CLISPRECORDTYPES) (SETQ SUBRECSTODO (CONS (CONS VAL VAR) SUBRECSTODO)))
(T (PROG ((TEM (CADR (CDDDDR HASHED)))) (COND ((FASSOC VAR (CADDR
TEM)) (RECORDERROR (QUOTE TWICE) TAIL RECORDECLARATION)) (T (FRPLACD
(CDR TEM) (CONS (CONS (LIST VAR VAL) (CADDR TEM)) (CDDDR TEM))))))))))
)
(DEFINEQ

(CLISPRECORD
(LAMBDA (RECEXPR FIELD SETQFLG) (LISPXWATCH RECORDSTATS) (PROG (DEF
(DECLST (GETLOCALDEC EXPR FAULTFN)) (CHECKFIELD FIELD) TAIL) (*
Handles records. When FIELD is NIL, RECEXPR is an expression such
as (fetch --) or (replace --) %. In this case, CLISPRECORD is to
do the appropriate lookups and construct the appropriate expresson,
which it returns as its value. it should also do the hashing. Note
that even if there are no local declaration, only global ones, it
shuld still construct the expression and hash on it. If there are
no local or global declaration, return NIL. I will handle the error.)
RETRY (COND ((AND FIELD (NLISTP FIELD)) (* X : FIELD input) (COND
(SETQFLG (COND ((SETQ DEF (ACCESSDEF FIELD DECLST RECEXPR T)) (*
Return intermediate result for next call) (RETURN (LIST (QUOTE replace)
FIELD DEF RECEXPR))) (T (GO ERROR)))) ((SETQ DEF (ACCESSDEF FIELD
DECLST RECEXPR)) (SETQ RECEXPR (LIST (QUOTE fetch) FIELD (QUOTE
of) RECEXPR)) (GO GOTDEF)) (T (GO ERROR)))) (SETQFLG (OR (EQ (CAR
RECEXPR) (QUOTE replace)) (HELP (QUOTE (BAD ARG TO CLISPRECORD))))
(* Second pass - Already done spelling correction) (SETQ DEF (CADDR
RECEXPR)) (FRPLACA (CDDR RECEXPR) (QUOTE of)) (FRPLACD (CDDDR RECEXPR)
(CONS (QUOTE with) FIELD)) (GO GOTDEF)) ((NLISTP RECEXPR) (RETURN)
(* X:NIL CASE)) (T (* User typein) (SETQ CHECKFIELD (CADR RECEXPR))
(SETQ TAIL (CDR RECEXPR)) (SETQ DEF (OR (SELECTQ (CAR RECEXPR) ((fetch
FETCH) (ACCESSDEF CHECKFIELD DECLST (CADDDR RECEXPR))) ((replace
REPLACE) (ACCESSDEF CHECKFIELD DECLST (CADDDR RECEXPR) T)) (HELP
"BAD ARG TO CLISPRECORD" RECEXPR)) (GO ERROR))) (SELECTQ (CADDR
RECEXPR) ((of OF)) (OR (FIXSPELL (CADDR RECEXPR) 70 (QUOTE (OF of))
NIL (CDDR RECEXPR) NIL T) (RECORDERROR (QUOTE OF) (CDDR RECEXPR)
RECEXPR))) (SETQ TAIL (CDDDR RECEXPR)) (DWIMIFY1B TAIL RECEXPR T
T T FAULTFN) (SELECTQ (CAR RECEXPR) ((REPLACE replace) (SELECTQ
(CADR TAIL) ((with WITH)) (OR (FIXSPELL (CADR TAIL) 70 (QUOTE (WITH
with)) NIL (CDR TAIL) NIL T) (/RPLACD TAIL (CONS (QUOTE with) (CDDR
TAIL)))))) NIL) (GO GOTDEF))) GOTDEF (* DEF is either an atom; meaning
a function of (one argument for access) (two arguments for REPLACE)
; or LISTP, meaning a FORM of with BODY and ITEM; BODY being the
thing the "FIELD" is taken of, and ITEM , optional, being the replaced
value) (CLISPTRAN RECEXPR (MYSUBST DEF (CADDDR RECEXPR) (CDR (CDDDDR
RECEXPR)) DECLST)) (RETURN RECEXPR) ERROR (COND ((SETQ CHECKFIELD
(RECRESPELL CHECKFIELD DECLST TAIL)) (OR TAIL (SETQ FIELD CHECKFIELD))
(GO RETRY))))))

(RECRESPELL
(LAMBDA (FIELD DECLST TAIL) (FIXSPELL FIELD 70 (NCONC (MAPCONC DECLST
(FUNCTION (LAMBDA (X) (APPEND (CAR (RECORDECL X)))))) RECORDSPLIST)
NIL TAIL NIL T)))

(MYSUBST
(LAMBDA (FORM XITEM YITEM DECLST) (COND ((EQ FORM (QUOTE BODY))
XITEM) ((NLISTP FORM) (CONS (RECLISPLOOKUP FORM XITEM DECLST) (CONS
XITEM YITEM))) ((MYSUBST1 FORM T)) (T (HELP "ERROR IN RECORD")))))

(RECLISPLOOKUP
(LAMBDA (WORD VAR1 DECLST) (PROG ((LISPFN (GETP WORD (QUOTE LISPFN)))
CLASSDEF) (COND ((AND DECLST (SETQ CLASSDEF (GETP WORD (QUOTE 
CLISPCLASSDEF)))) (* must do full lookup. Note that it is not 
necessary to do a call to CLISPLOOKUP0 if word has a CLASS, but
no CLASSDEF, e.g. FGTP, FMEMB, etc., since if these are ued as infix
operators, they mean the corresponding functin regardless of 
declaraton. I.e. The CLASSDEF property says that this is the name
of an infix operator. The CLASS property is used as a back pointer
to the name of the operator/class of which this word is a member.)
(CLISPLOOKUP0 WORD VAR1 NIL DECLST LISPFN (GETP WORD (QUOTE CLISPCLASS))
CLASSDEF)) (T (OR LISPFN WORD))))))

(MYSUBST1
(LAMBDA (FORM TOPFORM) (COND ((NLISTP FORM) NIL) ((EQ (CAR FORM)
(QUOTE BODY)) (CONS XITEM (OR (MYSUBST1 (CDR FORM)) (CDR FORM))))
((EQ (CAR FORM) (QUOTE ITEM)) (COND ((NULL (CDR FORM)) YITEM) (T
(APPEND YITEM (OR (MYSUBST1 (CDR FORM)) (CDR FORM)))))) (T (PROG
(A D) (SETQ D (MYSUBST1 (CDR FORM))) (COND ((NLISTP (CAR FORM))
(COND (TOPFORM (SETQ A (RECLISPLOOKUP (CAR FORM) XITEM DECLST))
(COND ((EQ A (CAR FORM)) (SETQ A NIL)))))) (T (SETQ A (MYSUBST1
(CAR FORM) T)))) (OR A D (RETURN)) (CONS (OR A (CAR FORM)) (OR D
(CDR FORM))))))))

(ACCESSDEF
(LAMBDA (FIELD DECLST VAR1 REPLACEFLG) (OR (AND (SETQ VAR1 (FASSOC
FIELD (CADDR (RECORDECL (OR (AND (COND ((EQ DECLST T) (SETQ DECLST
(GETLOCALDEC EXPR))) (T DECLST)) (CLISPLOOKUP0 FIELD VAR1 NIL DECLST
NIL (QUOTE RECORDFIELD))) (GETP FIELD (QUOTE CLISPRECORDFIELD)))
(QUOTE DON'TFIX))))) (COND (REPLACEFLG (OR (CADDR VAR1) (RECORDERROR
"replacement of this field not defined" FIELD RECEXPR))) (T (OR
(CADR VAR1) (RECORDERROR "access of this field not defined" FIELD
RECEXPR))))) (COND ((FMEMB FIELD SYSPROPS) (COND (REPLACEFLG (LIST
(QUOTE PUT) (QUOTE BODY) (KWOTE FIELD) (QUOTE ITEM))) (T (LIST (QUOTE
GETP) (QUOTE BODY) (KWOTE FIELD)))))))))

(GETLOCALDEC
(LAMBDA (EXPR FN) (PROG (TEM) (RETURN (COND ((AND (EQ (CAR (SETQ
TEM (CADDR EXPR))) (QUOTE *)) (EQ (CADR TEM) (QUOTE DECLARATIONS:)))
(CDDR TEM)) ((EQ (CAR TEM) (QUOTE CLISP:)) (CLISPDEC0 TEM (OR FN
FAULTFN))))))))
)
(DEFINEQ

(RECCOMPOSE0
(LAMBDA (CREATESTATEMENT) (LISPXWATCH RECORDSTATS) (PROG (HASHED
DECL FIELDS.IN.CREATE USINGTYPE USING TEM2 CREATE (BLIP (CONS))
BINDINGS) (* BLIP is used throughout the "COMPOSE" to indicate a
no-op) (SETQ CLISPCHANGE T) (OR (SETQ TEM2 (RECORDWORD (CAR 
CREATESTATEMENT))) (HELP)) (COND ((EQ TEM2 (QUOTE type)) (OR (SETQ
TEM2 (CADDDR (RECORDECL (RECLOOK (CADR CREATESTATEMENT) (CDR 
CREATESTATEMENT) (GETLOCALDEC EXPR FAULTFN) CREATESTATEMENT) T)))
(RECORDERROR "can't typecheck" CREATESTATEMENT)) (DWIMIFY1B (CDDR
CREATESTATEMENT) CREATESTATEMENT T T FAULTFN) (AND (CDDDR 
CREATESTATEMENT) (RECORDERROR "too many expressions" (CDDDR 
CREATESTATEMENT) CREATESTATEMENT)) (CLISPTRAN CREATESTATEMENT (MYSUBST
TEM2 (CADDR CREATESTATEMENT))) (RETURN CREATESTATEMENT))) (PROG
(TEM) (* find the "CREATE" expression) LPX (COND ((SETQ CREATE (SOME
CREATESTATEMENT (FUNCTION (LAMBDA (X) (EQ (RECORDWORD X) (QUOTE
create)))))) (SETQ HASHED (RECORDECL (SETQ DECL (RECLOOK (CADR CREATE)
(CDR CREATE) (GETLOCALDEC EXPR FAULTFN) CREATESTATEMENT)) T))))
(COND (TEM (OR CREATE (RECORDERROR (QUOTE NOCREATE) CREATESTATEMENT)))
(T (DWIMIFYREC (CDR CREATESTATEMENT) (NCONC (AND CREATE (APPEND
(CAR HASHED) (LIST (CADR CREATE)))) (APPEND CLISPRECORDWORDS)) 
CREATESTATEMENT) (COND ((NOT CREATE) (SETQ TEM T) (GO LPX))))))
(SETQ DECL (CLISPNOTRAN DECL)) (PROG ((TEM CREATESTATEMENT)) (*
Go through the create statement, picking up the field←'s and the
USING or COPYING, etc) LP2 (COND ((NULL TEM) (RETURN)) ((SETQ TEM2
(RECORDWORD (CAR TEM))) (SELECTQ TEM2 ((CREATE create) (* already
handled) T) (COND (USING (RECORDERROR (COND ((EQ (CAR TEM) (CAR
USING)) (CONCAT (CAR TEM) " appears twice")) (T (CONCAT "both "
(CAR TEM) " and " (CAR USING)))) TEM CREATESTATEMENT)) (T (SETQ
USINGTYPE TEM2) (SETQ USING TEM)))) (SETQ TEM (CDDR TEM))) (T (*
Adds the info to alist, or ERROR's - let it handle unrecognized
NLISTP's as well) (COND ((NLISTP (CAR TEM)) (RECORDERROR (QUOTE
NOFIELDS) TEM CREATESTATEMENT))) (SELECTQ (CAAR TEM) ((SETQ SAVESETQ))
((SETQQ SAVESETQQ) (/RPLNODE (CAR TEM) (QUOTE SETQ) (LIST (CADAR
TEM) (KWOTE (CADDR (CAR TEM)))))) (RECORDERROR (QUOTE NOFIELD) TEM
CREATESTATEMENT)) (COND ((FASSOC (CADAR TEM) FIELDS.IN.CREATE) (
RECORDERROR (QUOTE TWICE) TEM CREATESTATEMENT)) ((FMEMB (CADAR TEM)
(CAR HASHED)) (SETQ FIELDS.IN.CREATE (CONS (CDAR TEM) FIELDS.IN.CREATE))
(SETQ TEM (PROG1 (CDR TEM) (/RPLNODE TEM (CADAR TEM) (CONS (QUOTE
←) (CONS (CADDR (CAR TEM)) (CDR TEM))))))) ((FIXSPELL (CADAR TEM)
70 (CAR HASHED) NIL (CDAR TEM) NIL T) (GO LP2)) (T (RECORDERROR
(QUOTE FIELDS) TEM CREATESTATEMENT))))) (GO LP2)) (SETQ TEM2 (
RECCOMPOSE HASHED (AND USINGTYPE (COND ((LISTP (CADR USING)) (CAAR
(SETQ BINDINGS (CONS (LIST (QUOTE $$TEM1) (CADR USING)) BINDINGS))))
(T (CADR USING)))))) (AND BINDINGS (SETQ TEM2 (LIST (QUOTE PROG)
BINDINGS (LIST (QUOTE RETURN) TEM2)))) (CLISPTRAN CREATESTATEMENT
TEM2) (OR (AND (EQ (CAR CREATESTATEMENT) (CAR CREATE)) (EQUAL (CDR
CREATESTATEMENT) (SETQ TEM2 (CONS (CADR CREATE) (NCONC (AND USING
(LIST (CAR USING) (CADR USING))) (SETPACK FIELDS.IN.CREATE))))))
(/RPLNODE CREATESTATEMENT (CAR CREATE) TEM2)) (RETURN CREATESTATEMENT)))
)

(RECORDWORD
(LAMBDA (WORD) (AND (EQ (CAR (SETQ WORD (GETP WORD (QUOTE CLISPWORD))))
(QUOTE RECORDWORD)) (COND ((LISTP (CDR WORD)) (CADDR WORD)) (T (CDR
WORD))))))

(RECLOOK
(LAMBDA (RECNAME TAIL LOCALDEC PARENT) (* LOOKS FOR RECORD DECLARATION)
(PROG (TEM) RETRY (OR (COND ((NLISTP RECNAME) (OR (AND LOCALDEC
(CLISPLOOKUP0 RECNAME NIL NIL LOCALDEC NIL (QUOTE RECORD))) (GETP
RECNAME (QUOTE CLISPRECORD)) (COND ((SETQ TEM (FIXSPELL RECNAME
70 (NCONC (MAPCONC LOCALDEC (FUNCTION (LAMBDA (X) (SETQ X (RECORDECL
X)) (LIST (CADR X))))) USERRECORDS) NIL TAIL NIL T)) (SETQ RECNAME
TEM) (GO RETRY))))) ((FMEMB (CAR RECNAME) CLISPRECORDTYPES) RECNAME))
(RECORDERROR "Undefined record name" TAIL PARENT)))))
)
(RPAQQ CLISPRECORDTYPES (RECORD TYPERECORD OPTIONS PROPRECORD HASHLINK
ACCESSFN HASHRECORD ATOMRECORD ARRAYRECORD ACCESSFNS MATCHRECORD))
(RPAQQ CLISPRECORDWORDS (SMASHING COPYREUSING CREATE USING COPYING
REUSING create using copying reusing copyreusing smashing))
(RPAQQ CRLIST ((CAR CAAR CDAR CAR NIL) (CDR CADR CDDR CDR NIL) (CDDDDR
NIL NIL CDR CDDDR) (CADDDR NIL NIL CAR CDDDR) (CDDDR CADDDR CDDDDR
CDR CDDR) (CDADDR NIL NIL CDR CADDR) (CAADDR NIL NIL CAR CADDR)
(CADDR CAADDR CDADDR CAR CDDR) (CDDR CADDR CDDDR CDR CDR) (CDDADR
NIL NIL CDR CDADR) (CADADR NIL NIL CAR CDADR) (CDADR CADADR CDDADR
CDR CADR) (CDAADR NIL NIL CDR CAADR) (CAAADR NIL NIL CAR CAADR)
(CAADR CAAADR CDAADR CAR CADR) (CADR CAADR CDADR CAR CDR) (CDDDAR
NIL NIL CDR CDDAR) (CADDAR NIL NIL CAR CDDAR) (CDDAR CADDAR CDDDAR
CDR CDAR) (CDADAR NIL NIL CDR CADAR) (CAADAR NIL NIL CAR CADAR)
(CADAR CAADAR CDADAR CAR CDAR) (CDAR CADAR CDDAR CDR CAR) (CDDAAR
NIL NIL CDR CDAAR) (CADAAR NIL NIL CAR CDAAR) (CDAAR CADAAR CDDAAR
CDR CAAR) (CDAAAR NIL NIL CDR CAAAR) (CAAAAR NIL NIL CAR CAAAR)
(CAAAR CAAAAR CDAAAR CAR CAAR) (CAAR CAAAR CDAAR CAR CAR)))
(RPAQ RECORDSPLIST (LIST NIL))
(RPAQ CHANGEDRECLST NIL)
(RPAQ USERRECORDS NIL)
(RPAQQ RECORDSUBSTFLG @@)
(RPAQ ACCESSNOTRANFLG T)
(DEFLIST(QUOTE(
(SMASHING (RECORDWORD . smashing))
(COPYREUSING NIL)
(CREATE (RECORDWORD . create))
(USING (RECORDWORD . using))
(COPYING (RECORDWORD . copying))
(REUSING (RECORDWORD . reusing))
(create (RECORDWORD . create))
(using (RECORDWORD . using))
(copying (RECORDWORD . copying))
(reusing (RECORDWORD . reusing))
(copyreusing NIL)
(smashing NIL)
))(QUOTE CLISPWORD))

(DEFLIST(QUOTE(
(RECORDS (LAMBDA (X Y) (AND (EQ (CAR X) Y) (CDR X))))
))(QUOTE PRETTYTYPE))

(ADDTOVAR PRETTYTYPELST (CHANGEDRECLST RECORDS "records"))
(ADDTOVAR PRETTYMACROS (RECORDS X (PD * (MAPCAR (QUOTE X) (FUNCTION
(LAMBDA (Z) (OR (LISTP Z) (LISTP (GETP Z (QUOTE CLISPRECORD))) (ERROR
Z "not a record"))))))))
(ADDTOVAR SYSPROPS CLISPRECORD CLISPRECORDFIELD)
(DEFINEQ

(CLISPNOTRAN
(LAMBDA (X) (* This function doesn't really do much; it is just
A canonical way of checking for the CLISPTRANFLG; i really shouldn't
worry about it working when the CLISPARRAY is off; but, well, i
did it) (COND ((AND (LISTP X) (EQ (CAR X) CLISPTRANFLG)) (CDDR X))
(T X))))

(MAKECREATE
(LAMBDA (RECORD.HASHED USINGEXPR) (PROG ((CREATEINFO (CADR (CDDDDR
RECORD.HASHED))) TEM TEM2) (COND ((EQ USINGTYPE (QUOTE reusing))
(OR (SPECIFIED RECORD.HASHED) (RETURN BLIP)))) (COND ((SETQ TEM
(SOME (CDDDR (CDDDDR RECORD.HASHED)) (FUNCTION (LAMBDA (X) (AND
(EQ (CAR (CADR (CDDDDR X))) (QUOTE HASHLINK)) (OR (NULL (CADR X))
(EQ (CADR X) (CADR RECORD.HASHED)))))))) (MYSUBST (CADDR (CAR (CADDR
(CAR TEM)))) (COND ((EQ (SETQ TEM2 (MAKECREATE1 CREATEINFO)) BLIP)
(HELP)) ((NLISTP TEM2) TEM2) (T (CAAR (SETQ BINDINGS (CONS (LIST
(GENSYML) TEM2) BINDINGS))))) (PROG ((RECORD.HASHED TEM)) (
MAKEINSTANCE (CADR (CADR (CDDDDR (CAR TEM)))) NIL USINGEXPR T T
(COND ((EQ USINGTYPE (QUOTE reusing)) (QUOTE using)) (T USINGTYPE)))))))
(COND ((SOME (RECORD.HASHED::7) (QUOTE SPECIFIED)) (RECORDERROR
(QUOTE NOTFIRSTFIELD) CREATESTATEMENT))) (MAKECREATE1 CREATEINFO))))

(MAKEINSTANCE
(LAMBDA (NAME ERMESS USINGEXPR USEUNIVDEFAULT COMPOSEWITHUSING USETYPE)
(PROG (TEM (VALUE (CDR (FASSOC NAME FIELDS.IN.CREATE))) (SUBFIELDS
(SOME (CADDR (CDDDDR RECORD.HASHED)) (FUNCTION (LAMBDA (X) (EQ (CADR
X) NAME))))) (DEFAULTS (CADDR (CADR (CDDDDR RECORD.HASHED))))) (COND
((SOME (CDR SUBFIELDS) (FUNCTION (LAMBDA (SUBFIELD) (AND (EQ (CADR
SUBFIELD) NAME) (SPECIFIED SUBFIELD))))) (RECORDERROR 'NOTFIRSTFIELD
CREATESTATEMENT))) (COND (VALUE (PROG ((VALUE (COND ((AND 
RECORDSUBSTFLG USETYPE) (SUBST (COND (COMPOSEWITHUSING (MYSUBST
(CADR (FASSOC NAME (CADDR RECORD.HASHED))) USINGEXPR)) (T USINGEXPR))
RECORDSUBSTFLG (CAR VALUE))) (T (CAR VALUE)))) (USINGTYPE (QUOTE
reusing))) (RETURN (COND ((SPECIFIED (CAR SUBFIELDS)) (MAKECREATE
(CAR SUBFIELDS) VALUE)) (T VALUE))))) (USETYPE (PROG ((USINGEXPR
(COND (COMPOSEWITHUSING (MYSUBST (CADR (FASSOC NAME (CADDR 
RECORD.HASHED))) USINGEXPR)) (T USINGEXPR)))) (RETURN (SELECTQ USETYPE
(reusing (COND ((SPECIFIED (CAR SUBFIELDS)) (MAKECREATE (CAR SUBFIELDS)
USINGEXPR)) (ERMESS (RECORDERROR ERMESS CREATESTATEMENT)) (T BLIP)))
(COND (SUBFIELDS (MAKECREATE (CAR SUBFIELDS) USINGEXPR)) (T (SELECTQ
USETYPE (copying (LIST (QUOTE COPY) USINGEXPR)) USINGEXPR)))))))
(SUBFIELDS (MAKECREATE (CAR SUBFIELDS))) ((SETQ TEM (FASSOC NAME
DEFAULTS)) (CADR TEM)) (USEUNIVDEFAULT (CADR (FASSOC (QUOTE DEFAULT)
DEFAULTS))) (T BLIP)))))

(SPECIFIED
(LAMBDA (RECORD.HASHED) (SOME (CAR RECORD.HASHED) (FUNCTION (LAMBDA
(X) (FASSOC X FIELDS.IN.CREATE))))))

(RECCOMPOSE
(LAMBDA (RECORD.HASHED USINGEXPR) (PROG ((TEM (MAKECREATE 
RECORD.HASHED USINGEXPR))) (COND ((EQ TEM BLIP) (RECORDERROR 
"REUSING with no fields specified;" CREATESTATEMENT)) (T TEM)))))

(MAKECREATELST
(LAMBDA (TEMPLATE CARFLG USINGEXPR) (COND ((NLISTP TEMPLATE) (
MAKEINSTANCE TEMPLATE NIL USINGEXPR (OR TEMPLATE CARFLG) NIL USINGTYPE))
(T (PROG ((A (MAKECREATELST (CAR TEMPLATE) T ('CAR USINGEXPR)))
(D (MAKECREATELST (CDR TEMPLATE) NIL ('CDR USINGEXPR)))) (COND ((AND
(EQ A BLIP) (EQ D BLIP)) BLIP) (T ('CONS (COND ((EQ A BLIP) ('CAR
USINGEXPR)) (T A)) (COND ((EQ D BLIP) ('CDR USINGEXPR)) (T D))))))))))

(SETPACK
(LAMBDA (ALIST) (MAPCONC ALIST (FUNCTION (LAMBDA (TEM) (AND (CDR
TEM) (LIST (CAR TEM) (QUOTE ←) (CADR TEM))))))))

('CONS
(LAMBDA (CARPART CDRPART) (COND ((OR (EQ (CAR CDRPART) (QUOTE LIST))
(NOT (CAR CDRPART))) (CONS (QUOTE LIST) (CONS CARPART (CDR CDRPART))))
(T (LIST (QUOTE CONS) CARPART CDRPART)))))
)
(DECLARE
(BLOCK: RECORDBLOCK (ENTRIES RECORD1 CLISPRECORD RECORDECL RECCOMPOSE0)
RECORD1 ADDGLOBVAR RECORDECL RECORDECL1 DECLTHISREC SETUPARRAY 'CAR
LISTRECORDEFS MAKERPLAC COMPOSE 'CDR DWIMIFYREC RECORDERROR 
DECLSUBFIELD CLISPRECORD RECRESPELL MYSUBST RECLISPLOOKUP MYSUBST1
ACCESSDEF GETLOCALDEC RECCOMPOSE0 RECORDWORD RECLOOK CLISPNOTRAN
MAKECREATE MAKEINSTANCE SPECIFIED RECCOMPOSE MAKECREATELST SETPACK
'CONS (GLOBALVARS CLISPRECORDWORDS CLISPRECORDTYPES RECORDSPLIST
RECORDSUBSTFLG RECORDSTATS USERRECORDS CRLIST) (SPECVARS EXPR FAULTFN
VARS CLISPCHANGE REDECLARELST) (LOCALFREEVARS RECORD.HASHED 
CREATESTATEMENT BINDINGS BLIP FIELDS.IN.CREATE USINGTYPE RECEXPR
DECLST YITEM XITEM RECORDECLARATION SUBRECSTODO))
)(DEFINEQ

(MAKECREATE1
(LAMBDA (CREATEINFO) (SELECTQ (CAR CREATEINFO) (RECORD (MAKECREATELST
(CADR CREATEINFO) T USINGEXPR)) (TYPERECORD ('CONS (KWOTE (CAADR
CREATEINFO)) (MAKECREATELST (CDADR CREATEINFO) T USINGEXPR))) (
PROPRECORD (SETQ TEM (for X in (CDADR CREATEINFO) bind TEM when
(NEQ (SETQ TEM (MAKEINSTANCE (SETQ X (OR (CAR (LISTP X)) X)) NIL
USINGEXPR T T (AND USINGTYPE (QUOTE reusing)))) BLIP) collect (LIST
(KWOTE X) TEM))) (COND ((NULL USINGTYPE) (CONS (QUOTE LIST) (NCONC
(AND (CAADR CREATEINFO) (LIST (CAADR CREATEINFO))) (for X in TEM
join X)))) (T (SETQ TEM2 (MYSUBST (SELECTQ USINGTYPE (copying (QUOTE
COPY)) (QUOTE APPEND)) USINGEXPR)) (for X in TEM do (SETQ TEM2 (LIST
(COND ((CAADR CREATEINFO) (QUOTE PUTLD)) (T (QUOTE PUTL))) TEM2
(CAR X) (CADR X)))) TEM2))) (ARRAYRECORD (PROG ((TEM (GENSYM)) 
EXPRESSION TEM1 TEM2) (SETQ BINDINGS (CONS (LIST TEM (LIST (QUOTE
ARRAY) (CAADR CREATEINFO) NIL (CADR (FASSOC (QUOTE DEFAULT) (CADDR
CREATEINFO))))) BINDINGS)) (SETQ TEM1 (CDADR CREATEINFO)) (FOR I
FROM 1 TO (CAADR CREATEINFO) DO (COND ((EQ (CDAR TEM1) I) (SETQ
TEM2 (MAKEINSTANCE (CAAR TEM1) NIL USINGEXPR NIL T USINGTYPE)) (SETQ
TEM1 (CDR TEM1))) (USINGTYPE (SETQ TEM2 (LIST (QUOTE ELT) USINGEXPR
I)) (COND ((EQ USINGTYPE (QUOTE copying)) (SETQ TEM2 (LIST (QUOTE
COPY) TEM2))))) (T (SETQ TEM2 BLIP))) (COND ((NEQ BLIP TEM2) (SETQ
EXPRESSION (CONS (LIST (QUOTE SETA) TEM I TEM2) EXPRESSION)))))
(RETURN (CONS (QUOTE PROGN) (DREVERSE (CONS TEM EXPRESSION))))))
(RECORDERROR (LIST "CREATE of " (CAR CREATEINFO) "'s not implemented.")
CREATESTATEMENT))))
)
STOP